home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / library / menu.tcl < prev    next >
Encoding:
Text File  |  1995-06-26  |  22.1 KB  |  837 lines
  1. # menu.tcl --
  2. #
  3. # This file defines the default bindings for Tk menus and menubuttons.
  4. # It also implements keyboard traversal of menus and implements a few
  5. # other utility procedures related to menus.
  6. #
  7. # @(#) menu.tcl 1.51 95/06/25 16:11:23
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. #-------------------------------------------------------------------------
  17. # Elements of tkPriv that are used in this file:
  18. #
  19. # cursor -        Saves the -cursor option for the posted menubutton.
  20. # focus -        Saves the focus during a menu selection operation.
  21. #            Focus gets restored here when the menu is unposted.
  22. # inMenubutton -    The name of the menubutton widget containing
  23. #            the mouse, or an empty string if the mouse is
  24. #            not over any menubutton.
  25. # popup -        If a menu has been popped up via tk_popup, this
  26. #            gives the name of the menu.  Otherwise this
  27. #            value is empty.
  28. # postedMb -        Name of the menubutton whose menu is currently
  29. #            posted, or an empty string if nothing is posted
  30. #            A grab is set on this widget.
  31. # relief -        Used to save the original relief of the current
  32. #            menubutton.
  33. # window -        When the mouse is over a menu, this holds the
  34. #            name of the menu;  it's cleared when the mouse
  35. #            leaves the menu.
  36. #-------------------------------------------------------------------------
  37.  
  38. #-------------------------------------------------------------------------
  39. # Overall note:
  40. # This file is tricky because there are four different ways that menus
  41. # can be used:
  42. #
  43. # 1. As a pulldown from a menubutton.  This is the most common usage.
  44. #    In this style, the variable tkPriv(postedMb) identifies the posted
  45. #    menubutton.
  46. # 2. As a torn-off menu copied from some other menu.  In this style
  47. #    tkPriv(postedMb) is empty, and the top-level menu is no
  48. #    override-redirect.
  49. # 3. As an option menu, triggered from an option menubutton.  In thi
  50. #    style tkPriv(postedMb) identifies the posted menubutton.
  51. # 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
  52. #    the top-level menu is override-redirect.
  53. #
  54. # The various binding procedures use the  state described above to
  55. # distinguish the various cases and take different actions in each
  56. # case.
  57. #-------------------------------------------------------------------------
  58.  
  59. #-------------------------------------------------------------------------
  60. # The code below creates the default class bindings for menus
  61. # and menubuttons.
  62. #-------------------------------------------------------------------------
  63.  
  64. bind Menubutton <FocusIn> {}
  65. bind Menubutton <Enter> {
  66.     tkMbEnter %W
  67. }
  68. bind Menubutton <Leave> {
  69.     tkMbLeave %W
  70. }
  71. bind Menubutton <1> {
  72.     if {$tkPriv(inMenubutton) != ""} {
  73.     tkMbPost $tkPriv(inMenubutton) %X %Y
  74.     }
  75. }
  76. bind Menubutton <Motion> {
  77.     tkMbMotion %W up %X %Y
  78. }
  79. bind Menubutton <B1-Motion> {
  80.     tkMbMotion %W down %X %Y
  81. }
  82. bind Menubutton <ButtonRelease-1> {
  83.     tkMbButtonUp %W
  84. }
  85. bind Menubutton <space> {
  86.     tkMbPost %W
  87.     tkMenuFirstEntry [%W cget -menu]
  88. }
  89. bind Menubutton <Return> {
  90.     tkMbPost %W
  91.     tkMenuFirstEntry [%W cget -menu]
  92. }
  93.  
  94. # Must set focus when mouse enters a menu, in order to allow
  95. # mixed-mode processing using both the mouse and the keyboard.
  96.  
  97. bind Menu <FocusIn> {}
  98. bind Menu <Enter> {
  99.     set tkPriv(window) %W
  100.     focus %W
  101. }
  102. bind Menu <Leave> {
  103.     tkMenuLeave %W %X %Y %s
  104. }
  105. bind Menu <Motion> {
  106.     tkMenuMotion %W %y %s
  107. }
  108. bind Menu <ButtonPress> {
  109.     tkMenuButtonDown %W
  110. }
  111. bind Menu <ButtonRelease> {
  112.     tkMenuInvoke %W
  113. }
  114. bind Menu <space> {
  115.     tkMenuInvoke %W
  116. }
  117. bind Menu <Return> {
  118.     tkMenuInvoke %W
  119. }
  120. bind Menu <Escape> {
  121.     tkMenuEscape %W
  122. }
  123. bind Menu <Left> {
  124.     tkMenuLeftRight %W left
  125. }
  126. bind Menu <Right> {
  127.     tkMenuLeftRight %W right
  128. }
  129. bind Menu <Up> {
  130.     tkMenuNextEntry %W -1
  131. }
  132. bind Menu <Down> {
  133.     tkMenuNextEntry %W +1
  134. }
  135. bind Menu <KeyPress> {
  136.     tkTraverseWithinMenu %W %A
  137. }
  138.  
  139. # The following bindings apply to all windows, and are used to
  140. # implement keyboard menu traversal.
  141.  
  142. bind all <Alt-KeyPress> {
  143.     tkTraverseToMenu %W %A
  144. }
  145. bind all <F10> {
  146.     tkFirstMenu %W
  147. }
  148.  
  149. # tkMbEnter --
  150. # This procedure is invoked when the mouse enters a menubutton
  151. # widget.  It activates the widget unless it is disabled.  Note:
  152. # this procedure is only invoked when mouse button 1 is *not* down.
  153. # The procedure tkMbB1Enter is invoked if the button is down.
  154. #
  155. # Arguments:
  156. # w -            The  name of the widget.
  157.  
  158. proc tkMbEnter w {
  159.     global tkPriv
  160.  
  161.     if {$tkPriv(inMenubutton) != ""} {
  162.     tkMbLeave $tkPriv(inMenubutton)
  163.     }
  164.     set tkPriv(inMenubutton) $w
  165.     if {[$w cget -state] != "disabled"} {
  166.     $w configure -state active
  167.     }
  168. }
  169.  
  170. # tkMbLeave --
  171. # This procedure is invoked when the mouse leaves a menubutton widget.
  172. # It de-activates the widget, if the widget still exists.
  173. #
  174. # Arguments:
  175. # w -            The  name of the widget.
  176.  
  177. proc tkMbLeave w {
  178.     global tkPriv
  179.  
  180.     set tkPriv(inMenubutton) {}
  181.     if ![winfo exists $w] {
  182.     return
  183.     }
  184.     if {[$w cget -state] == "active"} {
  185.     $w configure -state normal
  186.     }
  187. }
  188.  
  189. # tkMbPost --
  190. # Given a menubutton, this procedure does all the work of posting
  191. # its associated menu and unposting any other menu that is currently
  192. # posted.
  193. #
  194. # Arguments:
  195. # w -            The name of the menubutton widget whose menu
  196. #            is to be posted.
  197. # x, y -        Root coordinates of cursor, used for positioning
  198. #            option menus.  If not specified, then the center
  199. #            of the menubutton is used for an option menu.
  200.  
  201. proc tkMbPost {w {x {}} {y {}}} {
  202.     global tkPriv
  203.     if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} {
  204.     return
  205.     }
  206.     set menu [$w cget -menu]
  207.     if {($menu == "") || ([$menu index last] == "none")} {
  208.     return
  209.     }
  210.     if ![string match $w.* $menu] {
  211.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  212.     }
  213.     set cur $tkPriv(postedMb)
  214.     if {$cur != ""} {
  215.     tkMenuUnpost {}
  216.     }
  217.     set tkPriv(cursor) [$w cget -cursor]
  218.     set tkPriv(relief) [$w cget -relief]
  219.     $w configure -cursor arrow
  220.     $w configure -relief raised
  221.     set tkPriv(postedMb) $w
  222.     set tkPriv(focus) [focus]
  223.     $menu activate none
  224.  
  225.     # If this looks like an option menubutton then post the menu so
  226.     # that the current entry is on top of the mouse.  Otherwise post
  227.     # the menu just below the menubutton, as for a pull-down.
  228.  
  229.     if {([$w cget -indicatoron] == 1) && ([$w cget -textvariable] != "")} {
  230.     if {$y == ""} {
  231.         set x [expr [winfo rootx $w] + [winfo width $w]/2]
  232.         set y [expr [winfo rooty $w] + [winfo height $w]/2]
  233.     }
  234.     tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
  235.     } else {
  236.     $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  237.     }
  238.     focus $menu
  239.     grab -global $w
  240. }
  241.  
  242. # tkMenuUnpost --
  243. # This procedure unposts a given menu, plus all of its ancestors up
  244. # to (and including) a menubutton, if any.  It also restores various
  245. # values to what they were before the menu was posted, and releases
  246. # a grab if there's a menubutton involved.  Special notes:
  247. # 1. It's important to unpost all menus before releasing the grab, so
  248. #    that any Enter-Leave events (e.g. from menu back to main
  249. #    application) have mode NotifyGrab.
  250. # 2. Be sure to enclose various groups of commands in "catch" so that
  251. #    the procedure will complete even if the menubutton or the menu
  252. #    or the grab window has been deleted.
  253. #
  254. # Arguments:
  255. # menu -        Name of a menu to unpost.  Ignored if there
  256. #            is a posted menubutton.
  257.  
  258. proc tkMenuUnpost menu {
  259.     global tkPriv
  260.     set mb $tkPriv(postedMb)
  261.  
  262.     # Restore focus right away (otherwise X will take focus away when
  263.     # the menu is unmapped and under some window managers (e.g. olvwm)
  264.     # we'll lose the focus completely).
  265.  
  266.     catch {focus $tkPriv(focus)}
  267.     set tkPriv(focus) ""
  268.  
  269.     # Unpost menu(s) and restore some stuff that's dependent on
  270.     # what was posted.
  271.  
  272.     catch {
  273.     if {$mb != ""} {
  274.         set menu [$mb cget -menu]
  275.         $menu unpost
  276.         set tkPriv(postedMb) {}
  277.         $mb configure -cursor $tkPriv(cursor)
  278.         $mb configure -relief $tkPriv(relief)
  279.     } elseif {$tkPriv(popup) != ""} {
  280.         $tkPriv(popup) unpost
  281.         set tkPriv(popup) {}
  282.     } elseif {[wm overrideredirect $menu]} {
  283.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  284.         # Unpost all the menus up to the toplevel one (but not
  285.         # including the top-level torn-off one) and deactivate the
  286.         # top-level torn off menu if there is one.
  287.  
  288.         while 1 {
  289.         set parent [winfo parent $menu]
  290.         if {([winfo class $parent] != "Menu")
  291.             || ![winfo ismapped $parent]} {
  292.             break
  293.         }
  294.         $parent activate none
  295.         $parent postcascade none
  296.         if {![wm overrideredirect $parent]} {
  297.             break
  298.         }
  299.         set menu $parent
  300.         }
  301.         $menu unpost
  302.     }
  303.     }
  304.  
  305.     # Release grab, if any.
  306.  
  307.     if {$menu != ""} {
  308.     set grab [grab current $menu]
  309.     if {$grab != ""} {
  310.         grab release $grab
  311.     }
  312.     }
  313. }
  314.  
  315. # tkMbMotion --
  316. # This procedure handles mouse motion events inside menubuttons, and
  317. # also outside menubuttons when a menubutton has a grab (e.g. when a
  318. # menu selection operation is in progress).
  319. #
  320. # Arguments:
  321. # w -            The name of the menubutton widget.
  322. # upDown -         "down" means button 1 is pressed, "up" means
  323. #            it isn't.
  324. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  325.  
  326. proc tkMbMotion {w upDown rootx rooty} {
  327.     global tkPriv
  328.  
  329.     if {$tkPriv(inMenubutton) == $w} {
  330.     return
  331.     }
  332.     set new [winfo containing $rootx $rooty]
  333.     if {($new != $tkPriv(inMenubutton)) && (($new == "")
  334.         || ([winfo toplevel $new] == [winfo toplevel $w]))} {
  335.     if {$tkPriv(inMenubutton) != ""} {
  336.         tkMbLeave $tkPriv(inMenubutton)
  337.     }
  338.     if {($new != "") && ([winfo class $new] == "Menubutton")
  339.         && ([$new cget -indicatoron] == 0)} {
  340.         if {$upDown == "down"} {
  341.         tkMbPost $new $rootx $rooty
  342.         } else {
  343.         tkMbEnter $new
  344.         }
  345.     }
  346.     }
  347. }
  348.  
  349. # tkMbButtonUp --
  350. # This procedure is invoked to handle button 1 releases for menubuttons.
  351. # If the release happens inside the menubutton then leave its menu
  352. # posted with element 0 activated.  Otherwise, unpost the menu.
  353. #
  354. # Arguments:
  355. # w -            The name of the menubutton widget.
  356.  
  357. proc tkMbButtonUp w {
  358.     global tkPriv
  359.  
  360.     if  {($tkPriv(postedMb) == $w) && ($tkPriv(inMenubutton) == $w)} {
  361.     tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
  362.     } else {
  363.     tkMenuUnpost {}
  364.     }
  365. }
  366.  
  367. # tkMenuMotion --
  368. # This procedure is called to handle mouse motion events for menus.
  369. # It does two things.  First, it resets the active element in the
  370. # menu, if the mouse is over the menu.  Second, if a mouse button
  371. # is down, it posts and unposts cascade entries to match the mouse
  372. # position.
  373. #
  374. # Arguments:
  375. # menu -        The menu window.
  376. # y -            The y position of the mouse.
  377. # state -        Modifier state (tells whether buttons are down).
  378.  
  379. proc tkMenuMotion {menu y state} {
  380.     global tkPriv
  381.     if {$menu == $tkPriv(window)} {
  382.     $menu activate @$y
  383.     }
  384.     if {($state & 0x1f00) != 0} {
  385.     $menu postcascade active
  386.     }
  387. }
  388.  
  389. # tkMenuButtonDown --
  390. # Handles button presses in menus.  There are a couple of tricky things
  391. # here:
  392. # 1. Change the posted cascade entry (if any) to match the mouse position.
  393. # 2. If there is a posted menubutton, must grab to the menubutton so
  394. #    that it can track mouse motions over other menubuttons and change
  395. #    the posted menu.
  396. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  397. #    or one of its descendants) must grab to the top-level menu so that
  398. #    we can track mouse motions across the entire menu hierarchy.
  399. #
  400. # Arguments:
  401. # menu -        The menu window.
  402.  
  403. proc tkMenuButtonDown menu {
  404.     global tkPriv
  405.     $menu postcascade active
  406.     if {$tkPriv(postedMb) != ""} {
  407.     grab -global $tkPriv(postedMb)
  408.     } else {
  409.     while {[wm overrideredirect $menu]
  410.         && ([winfo class [winfo parent $menu]] == "Menu")
  411.         && [winfo ismapped [winfo parent $menu]]} {
  412.         set menu [winfo parent $menu]
  413.     }
  414.     grab -global $menu
  415.     }
  416. }
  417.  
  418. # tkMenuLeave --
  419. # This procedure is invoked to handle Leave events for a menu.  It
  420. # deactivates everything unless the active element is a cascade element
  421. # and the mouse is now over the submenu.
  422. #
  423. # Arguments:
  424. # menu -        The menu window.
  425. # rootx, rooty -    Root coordinates of mouse.
  426. # state -        Modifier state.
  427.  
  428. proc tkMenuLeave {menu rootx rooty state} {
  429.     global tkPriv
  430.     set tkPriv(window) {}
  431.     if {[$menu index active] == "none"} {
  432.     return
  433.     }
  434.     if {([$menu type active] == "cascade")
  435.         && ([winfo containing $rootx $rooty]
  436.         == [$menu entrycget active -menu])} {
  437.     return
  438.     }
  439.     $menu activate none
  440. }
  441.  
  442. # tkMenuInvoke --
  443. # This procedure is invoked when button 1 is released over a menu.
  444. # It invokes the appropriate menu action and unposts the menu if
  445. # it came from a menubutton.
  446. #
  447. # Arguments:
  448. # w -            Name of the menu widget.
  449.  
  450. proc tkMenuInvoke w {
  451.     if {[$w type active] == "cascade"} {
  452.     $w postcascade active
  453.     set menu [$w entrycget active -menu]
  454.     tkMenuFirstEntry $menu
  455.     } elseif {[$w type active] == "tearoff"} {
  456.     tkMenuUnpost $w
  457.     tkTearOffMenu $w
  458.     } else {
  459.     tkMenuUnpost $w
  460.     uplevel #0 [list $w invoke active]
  461.     }
  462. }
  463.  
  464. # tkMenuEscape --
  465. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  466. # the given menu and, if it is the top-level menu for a menu button,
  467. # unposts the menu button as well.
  468. #
  469. # Arguments:
  470. # menu -        Name of the menu window.
  471.  
  472. proc tkMenuEscape menu {
  473.     if {[winfo class [winfo parent $menu]] != "Menu"} {
  474.     tkMenuUnpost $menu
  475.     } else {
  476.     tkMenuLeftRight $menu -1
  477.     }
  478. }
  479.  
  480. # tkMenuLeftRight --
  481. # This procedure is invoked to handle "left" and "right" traversal
  482. # motions in menus.  It traverses to the next menu in a menu bar,
  483. # or into or out of a cascaded menu.
  484. #
  485. # Arguments:
  486. # menu -        The menu that received the keyboard
  487. #            event.
  488. # direction -        Direction in which to move: "left" or "right"
  489.  
  490. proc tkMenuLeftRight {menu direction} {
  491.     global tkPriv
  492.  
  493.     # First handle traversals into and out of cascaded menus.
  494.  
  495.     if {$direction == "right"} {
  496.     set count 1
  497.     if {[$menu type active] == "cascade"} {
  498.         $menu postcascade active
  499.         set m2 [$menu entrycget active -menu]
  500.         if {$m2 != ""} {
  501.         tkMenuFirstEntry $m2
  502.         }
  503.         return
  504.     }
  505.     } else {
  506.     set count -1
  507.     set m2 [winfo parent $menu]
  508.     if {[winfo class $m2] == "Menu"} {
  509.         $menu activate none
  510.         focus $m2
  511.  
  512.         # This code unposts any posted submenu in the parent.
  513.  
  514.         set tmp [$m2 index active]
  515.         $m2 activate none
  516.         $m2 activate $tmp
  517.         return
  518.     }
  519.     }
  520.  
  521.     # Can't traverse into or out of a cascaded menu.  Go to the next
  522.     # or previous menubutton, if that makes sense.
  523.  
  524.     set w $tkPriv(postedMb)
  525.     if {$w == ""} {
  526.     return
  527.     }
  528.     set buttons [winfo children [winfo parent $w]]
  529.     set length [llength $buttons]
  530.     set i [expr [lsearch -exact $buttons $w] + $count]
  531.     while 1 {
  532.     while {$i < 0} {
  533.         incr i $length
  534.     }
  535.     while {$i >= $length} {
  536.         incr i -$length
  537.     }
  538.     set mb [lindex $buttons $i]
  539.     if {([winfo class $mb] == "Menubutton")
  540.         && ([$mb cget -state] != "disabled")
  541.         && ([$mb cget -menu] != "")
  542.         && ([[$mb cget -menu] index last] != "none")} {
  543.         break
  544.     }
  545.     if {$mb == $w} {
  546.         return
  547.     }
  548.     incr i $count
  549.     }
  550.     tkMbPost $mb
  551.     tkMenuFirstEntry [$mb cget -menu]
  552. }
  553.  
  554. # tkMenuNextEntry --
  555. # Activate the next higher or lower entry in the posted menu,
  556. # wrapping around at the ends.  Disabled entries are skipped.
  557. #
  558. # Arguments:
  559. # menu -            Menu window that received the keystroke.
  560. # count -            1 means go to the next lower entry,
  561. #                -1 means go to the next higher entry.
  562.  
  563. proc tkMenuNextEntry {menu count} {
  564.     global tkPriv
  565.     if {[$menu index last] == "none"} {
  566.     return
  567.     }
  568.     set length [expr [$menu index last]+1]
  569.     set active [$menu index active]
  570.     if {$active == "none"} {
  571.     set i 0
  572.     } else {
  573.     set i [expr $active + $count]
  574.     }
  575.     while 1 {
  576.     while {$i < 0} {
  577.         incr i $length
  578.     }
  579.     while {$i >= $length} {
  580.         incr i -$length
  581.     }
  582.     if {[catch {$menu entrycget $i -state} state] == 0} {
  583.         if {$state != "disabled"} {
  584.         break
  585.         }
  586.     }
  587.     if {$i == $active} {
  588.         return
  589.     }
  590.     incr i $count
  591.     }
  592.     $menu activate $i
  593.     $menu postcascade $i
  594. }
  595.  
  596. # tkMenuFind --
  597. # This procedure searches the entire window hierarchy under w for
  598. # a menubutton that isn't disabled and whose underlined character
  599. # is "char".  It returns the name of that window, if found, or an
  600. # empty string if no matching window was found.  If "char" is an
  601. # empty string then the procedure returns the name of the first
  602. # menubutton found that isn't disabled.
  603. #
  604. # Arguments:
  605. # w -                Name of window where key was typed.
  606. # char -            Underlined character to search for;
  607. #                may be either upper or lower case, and
  608. #                will match either upper or lower case.
  609.  
  610. proc tkMenuFind {w char} {
  611.     global tkPriv
  612.     set char [string tolower $char]
  613.  
  614.     foreach child [winfo child $w] {
  615.     switch [winfo class $child] {
  616.         Menubutton {
  617.         set char2 [string index [$child cget -text] \
  618.             [$child cget -underline]]
  619.         if {([string compare $char [string tolower $char2]] == 0)
  620.             || ($char == "")} {
  621.             if {[$child cget -state] != "disabled"} {
  622.             return $child
  623.             }
  624.         }
  625.         }
  626.         Frame {
  627.         set match [tkMenuFind $child $char]
  628.         if {$match != ""} {
  629.             return $match
  630.         }
  631.         }
  632.     }
  633.     }
  634.     return {}
  635. }
  636.  
  637. # tkTraverseToMenu --
  638. # This procedure implements keyboard traversal of menus.  Given an
  639. # ASCII character "char", it looks for a menubutton with that character
  640. # underlined.  If one is found, it posts the menubutton's menu
  641. #
  642. # Arguments:
  643. # w -                Window in which the key was typed (selects
  644. #                a toplevel window).
  645. # char -            Character that selects a menu.  The case
  646. #                is ignored.  If an empty string, nothing
  647. #                happens.
  648.  
  649. proc tkTraverseToMenu {w char} {
  650.     if {$char == ""} {
  651.     return
  652.     }
  653.     while {[winfo class $w] == "Menu"} {
  654.     set w [winfo parent $w]
  655.     }
  656.     set w [tkMenuFind [winfo toplevel $w] $char]
  657.     if {$w != ""} {
  658.     tkMbPost $w
  659.     tkMenuFirstEntry [$w cget -menu]
  660.     }
  661. }
  662.  
  663. # tkFirstMenu --
  664. # This procedure traverses to the first menubutton in the toplevel
  665. # for a given window, and posts that menubutton's menu.
  666. #
  667. # Arguments:
  668. # w -                Name of a window.  Selects which toplevel
  669. #                to search for menubuttons.
  670.  
  671. proc tkFirstMenu w {
  672.     set w [tkMenuFind [winfo toplevel $w] ""]
  673.     if {$w != ""} {
  674.     tkMbPost $w
  675.     tkMenuFirstEntry [$w cget -menu]
  676.     }
  677. }
  678.  
  679. # tkTraverseWithinMenu
  680. # This procedure implements keyboard traversal within a menu.  It
  681. # searches for an entry in the menu that has "char" underlined.  If
  682. # such an entry is found, it is invoked and the menu is unposted.
  683. #
  684. # Arguments:
  685. # w -                The name of the menu widget.
  686. # char -            The character to look for;  case is
  687. #                ignored.  If the string is empty then
  688. #                nothing happens.
  689.  
  690. proc tkTraverseWithinMenu {w char} {
  691.     if {$char == ""} {
  692.     return
  693.     }
  694.     set char [string tolower $char]
  695.     set last [$w index last]
  696.     if {$last == "none"} {
  697.     return
  698.     }
  699.     for {set i 0} {$i <= $last} {incr i} {
  700.     if [catch {set char2 [string index \
  701.         [$w entrycget $i -label] \
  702.         [$w entrycget $i -underline]]}] {
  703.         continue
  704.     }
  705.     if {[string compare $char [string tolower $char2]] == 0} {
  706.         if {[$w type $i] == "cascade"} {
  707.         $w postcascade $i
  708.         $w activate $i
  709.         set m2 [$w entrycget $i -menu]
  710.         if {$m2 != ""} {
  711.             tkMenuFirstEntry $m2
  712.         }
  713.         } else {
  714.         tkMenuUnpost $w
  715.         uplevel #0 [list $w invoke $i]
  716.         }
  717.         return
  718.     }
  719.     }
  720. }
  721.  
  722. # tkMenuFirstEntry --
  723. # Given a menu, this procedure finds the first entry that isn't
  724. # disabled or a tear-off or separator, and activates that entry.
  725. # However, if there is already an active entry in the menu (e.g.,
  726. # because of a previous call to tkPostOverPoint) then the active
  727. # entry isn't changed.  This procedure also sets the input focus
  728. # to the menu.
  729. #
  730. # Arguments:
  731. # menu -        Name of the menu window (possibly empty).
  732.  
  733. proc tkMenuFirstEntry menu {
  734.     if {$menu == ""} {
  735.     return
  736.     }
  737.     focus $menu
  738.     if {[$menu index active] != "none"} {
  739.     return
  740.     }
  741.     set last [$menu index last]
  742.     if {$last == "none"} {
  743.     return
  744.     }
  745.     for {set i 0} {$i <= $last} {incr i} {
  746.     if {([catch {set state [$menu entrycget $i -state]}] == 0)
  747.         && ($state != "disabled") && ([$menu type $i] != "tearoff")} {
  748.         $menu activate $i
  749.         return
  750.     }
  751.     }
  752. }
  753.  
  754. # tkMenuFindName --
  755. # Given a menu and a text string, return the index of the menu entry
  756. # that displays the string as its label.  If there is no such entry,
  757. # return an empty string.  This procedure is tricky because some names
  758. # like "active" have a special meaning in menu commands, so we can't
  759. # always use the "index" widget command.
  760. #
  761. # Arguments:
  762. # menu -        Name of the menu widget.
  763. # s -            String to look for.
  764.  
  765. proc tkMenuFindName {menu s} {
  766.     set i ""
  767.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  768.     catch {set i [$menu index $s]}
  769.     return $i
  770.     }
  771.     set last [$menu index last]
  772.     if {$last == "none"} {
  773.     return
  774.     }
  775.     for {set i 0} {$i <= $last} {incr i} {
  776.     if ![catch {$menu entrycget $i -label} label] {
  777.         if {$label == $s} {
  778.         return $i
  779.         }
  780.     }
  781.     }
  782.     return ""
  783. }
  784.  
  785. # tkPostOverPoint --
  786. # This procedure posts a given menu such that a given entry in the
  787. # menu is centered over a given point in the root window.  It also
  788. # activates the given entry.
  789. #
  790. # Arguments:
  791. # menu -        Menu to post.
  792. # x, y -        Root coordinates of point.
  793. # entry -        Index of entry within menu to center over (x,y).
  794. #            If omitted or specified as {}, then the menu's
  795. #            upper-left corner goes at (x,y).
  796.  
  797. proc tkPostOverPoint {menu x y {entry {}}}  {
  798.     if {$entry != {}} {
  799.     if {$entry == [$menu index last]} {
  800.         incr y [expr -([$menu yposition $entry] \
  801.             + [winfo reqheight $menu])/2]
  802.     } else {
  803.         incr y [expr -([$menu yposition $entry] \
  804.             + [$menu yposition [expr $entry+1]])/2]
  805.     }
  806.     incr x [expr -[winfo reqwidth $menu]/2]
  807.     }
  808.     $menu post $x $y
  809.     if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  810.     $menu activate $entry
  811.     }
  812. }
  813.  
  814. # tk_popup --
  815. # This procedure pops up a menu and sets things up for traversing
  816. # the menu and its submenus.
  817. #
  818. # Arguments:
  819. # menu -        Name of the menu to be popped up.
  820. # x, y -        Root coordinates at which to pop up the
  821. #            menu.
  822. # entry -        Index of a menu entry to center over (x,y).
  823. #            If omitted or specified as {}, then menu's
  824. #            upper-left corner goes at (x,y).
  825.  
  826. proc tk_popup {menu x y {entry {}}} {
  827.     global tkPriv
  828.     if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} {
  829.     tkMenuUnpost {}
  830.     }
  831.     tkPostOverPoint $menu $x $y $entry
  832.     grab -global $menu
  833.     set tkPriv(popup) $menu
  834.     set tkPriv(focus) [focus]
  835.     focus $menu
  836. }
  837.